home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume24 / gnucalc / part25 < prev    next >
Encoding:
Text File  |  1991-10-31  |  55.5 KB  |  1,694 lines

  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i073:  gnucalc - GNU Emacs Calculator, v2.00, Part25/56
  4. Message-ID: <1991Oct31.072757.18242@sparky.imd.sterling.com>
  5. X-Md4-Signature: 5191220bb34440415fd008f4ae7bf5c5
  6. Date: Thu, 31 Oct 1991 07:27:57 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 73
  11. Archive-name: gnucalc/part25
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # do not concatenate these parts, unpack them in order with /bin/sh
  18. # file calc-rewr.el continued
  19. #
  20. if test ! -r _shar_seq_.tmp; then
  21.     echo 'Please unpack part 1 first!'
  22.     exit 1
  23. fi
  24. (read Scheck
  25.  if test "$Scheck" != 25; then
  26.     echo Please unpack part "$Scheck" next!
  27.     exit 1
  28.  else
  29.     exit 0
  30.  fi
  31. ) < _shar_seq_.tmp || exit 1
  32. if test ! -f _shar_wnt_.tmp; then
  33.     echo 'x - still skipping calc-rewr.el'
  34. else
  35. echo 'x - continuing file calc-rewr.el'
  36. sed 's/^X//' << 'SHAR_EOF' >> 'calc-rewr.el' &&
  37. ;;;         argument is stored in "reg"; otherwise (provided this is an `a r'
  38. ;;;         and not a `g r' command) the selected part is stored in "reg".
  39. ;;;
  40. ;;; (cond expr)
  41. ;;;         The "expr", with registers substituted, must simplify to
  42. ;;;         a non-zero value.
  43. ;;;
  44. ;;; (let reg expr)
  45. ;;;         Evaluate "expr" and store the result in "reg".  Always succeeds.
  46. ;;;
  47. ;;; (done rhs remember)
  48. ;;;         Rewrite the expression to "rhs", with register substituted.
  49. ;;;        Normalize; if the result is different from the original
  50. ;;;        expression, the match has succeeded.  This is the last
  51. ;;;        instruction of every program.  If "remember" is non-nil,
  52. ;;;         record the result of the match as a new literal rule.
  53. X
  54. X
  55. ;;; Pseudo-functions related to rewrites:
  56. ;;;
  57. ;;;  In patterns:  quote, plain, condition, opt, apply, cons, select
  58. ;;;
  59. ;;;  In righthand sides:  quote, plain, eval, evalsimp, evalextsimp,
  60. ;;;                       apply, cons, select
  61. ;;;
  62. ;;;  In conditions:  let + same as for righthand sides
  63. X
  64. ;;; Some optimizations that would be nice to have:
  65. ;;;
  66. ;;;  * Merge registers with disjoint lifetimes.
  67. ;;;  * Merge constant registers with equivalent values.
  68. ;;;
  69. ;;;  * If an argument of a commutative op math-depends neither on the
  70. ;;;    rest of the pattern nor on any of the conditions, then no backtracking
  71. ;;;    should be done for that argument.  (This won't apply to very many
  72. ;;;    cases.)
  73. ;;;
  74. ;;;  * If top functor is "select", and its argument is a unique function,
  75. ;;;    add the rule to the lists for both "select" and that function.
  76. ;;;    (Currently rules like this go on the "nil" list.)
  77. ;;;    Same for "func-opt" functions.  (Though not urgent for these.)
  78. ;;;
  79. ;;;  * Shouldn't evaluate a "let" condition until the end, or until it
  80. ;;;    would enable another condition to be evaluated.
  81. ;;;
  82. X
  83. ;;; Some additional features to add / things to think about:
  84. ;;;
  85. ;;;  * Figure out what happens to "a +/- b" and "a +/- opt(b)".
  86. ;;;
  87. ;;;  * Same for interval forms.
  88. ;;;
  89. ;;;  * Have a name(v,pat) pattern which matches pat, and gives the
  90. ;;;    whole match the name v.  Beware of circular structures!
  91. ;;;
  92. X
  93. (defun math-compile-patterns (pats)
  94. X  (if (and (eq (car-safe pats) 'var)
  95. X       (calc-var-value (nth 2 pats)))
  96. X      (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
  97. X    (or prop
  98. X        (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
  99. X    (or (eq (car prop) (symbol-value (nth 2 pats)))
  100. X        (progn
  101. X          (setcdr prop (math-compile-patterns
  102. X                (symbol-value (nth 2 pats))))
  103. X          (setcar prop (symbol-value (nth 2 pats)))))
  104. X    (cdr prop))
  105. X    (let ((math-rewrite-whole t))
  106. X      (cdr (math-compile-rewrites (cons
  107. X                   'vec
  108. X                   (mapcar (function (lambda (x)
  109. X                               (list 'vec x
  110. X                                 '(var XXX XXX))))
  111. X                       (if (eq (car-safe pats) 'vec)
  112. X                           (cdr pats)
  113. X                         (list pats))))))))
  114. )
  115. (setq math-rewrite-whole nil)
  116. (setq math-make-import-list nil)
  117. X
  118. (defun math-compile-rewrites (rules &optional name)
  119. X  (if (eq (car-safe rules) 'var)
  120. X      (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
  121. X        (math-import-list nil)
  122. X        (math-make-import-list t)
  123. X        p)
  124. X    (or (calc-var-value (nth 2 rules))
  125. X        (error "Rules variable %s has no stored value" (nth 1 rules)))
  126. X    (or prop
  127. X        (put (nth 2 rules) 'math-rewrite-cache
  128. X         (setq prop (list (list (cons (nth 2 rules) nil))))))
  129. X    (setq p (car prop))
  130. X    (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
  131. X      (setq p (cdr p)))
  132. X    (or (null p)
  133. X        (progn
  134. X          (message "Compiling rule set %s..." (nth 1 rules))
  135. X          (setcdr prop (math-compile-rewrites
  136. X                (symbol-value (nth 2 rules))
  137. X                (nth 2 rules)))
  138. X          (message "Compiling rule set %s...done" (nth 1 rules))
  139. X          (setcar prop (cons (cons (nth 2 rules)
  140. X                       (symbol-value (nth 2 rules)))
  141. X                 math-import-list))))
  142. X    (cdr prop))
  143. X    (if (or (not (eq (car-safe rules) 'vec))
  144. X        (and (memq (length rules) '(3 4))
  145. X         (let ((p rules))
  146. X           (while (and (setq p (cdr p))
  147. X                   (memq (car-safe (car p))
  148. X                     '(vec
  149. X                       calcFunc-assign
  150. X                       calcFunc-condition
  151. X                       calcFunc-import
  152. X                       calcFunc-phase
  153. X                       calcFunc-schedule
  154. X                       calcFunc-iterations))))
  155. X           p)))
  156. X    (setq rules (list rules))
  157. X      (setq rules (cdr rules)))
  158. X    (if (assq 'calcFunc-import rules)
  159. X    (let ((pp (setq rules (copy-sequence rules)))
  160. X          p part)
  161. X      (while (setq p (car (cdr pp)))
  162. X        (if (eq (car-safe p) 'calcFunc-import)
  163. X        (progn
  164. X          (setcdr pp (cdr (cdr pp)))
  165. X          (or (and (eq (car-safe (nth 1 p)) 'var)
  166. X               (setq part (calc-var-value (nth 2 (nth 1 p))))
  167. X               (memq (car-safe part) '(vec
  168. X                           calcFunc-assign
  169. X                           calcFunc-condition)))
  170. X              (error "Argument of import() must be a rules variable"))
  171. X          (if math-make-import-list
  172. X              (setq math-import-list
  173. X                (cons (cons (nth 2 (nth 1 p))
  174. X                    (symbol-value (nth 2 (nth 1 p))))
  175. X                  math-import-list)))
  176. X          (while (setq p (cdr (cdr p)))
  177. X            (or (cdr p)
  178. X            (error "import() must have odd number of arguments"))
  179. X            (setq part (math-rwcomp-substitute part
  180. X                               (car p) (nth 1 p))))
  181. X          (if (eq (car-safe part) 'vec)
  182. X              (setq part (cdr part))
  183. X            (setq part (list part)))
  184. X          (setcdr pp (append part (cdr pp))))
  185. X          (setq pp (cdr pp))))))
  186. X    (let ((rule-set nil)
  187. X      (all-heads nil)
  188. X      (nil-rules nil)
  189. X      (rule-count 0)
  190. X      (math-schedule nil)
  191. X      (math-iterations nil)
  192. X      (math-phases nil)
  193. X      (math-all-phases nil)
  194. X      (math-remembering nil)
  195. X      math-pattern math-rhs math-conds)
  196. X      (while rules
  197. X    (cond
  198. X     ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
  199. X           (= (length (car rules)) 2))
  200. X      (or (integerp (nth 1 (car rules)))
  201. X          (equal (nth 1 (car rules)) '(var inf var-inf))
  202. X          (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
  203. X          (error "Invalid argument for iterations(n)"))
  204. X      (or math-iterations
  205. X          (setq math-iterations (nth 1 (car rules)))))
  206. X     ((eq (car-safe (car rules)) 'calcFunc-schedule)
  207. X      (or math-schedule
  208. X          (setq math-schedule (math-parse-schedule (cdr (car rules))))))
  209. X     ((eq (car-safe (car rules)) 'calcFunc-phase)
  210. X      (setq math-phases (cdr (car rules)))
  211. X      (if (equal math-phases '((var all var-all)))
  212. X          (setq math-phases nil))
  213. X      (let ((p math-phases))
  214. X        (while p
  215. X          (or (integerp (car p))
  216. X          (error "Phase numbers must be small integers"))
  217. X          (or (memq (car p) math-all-phases)
  218. X          (setq math-all-phases (cons (car p) math-all-phases)))
  219. X          (setq p (cdr p)))))
  220. X     ((or (and (eq (car-safe (car rules)) 'vec)
  221. X           (cdr (cdr (car rules)))
  222. X           (not (nthcdr 4 (car rules)))
  223. X           (setq math-conds (nth 3 (car rules))
  224. X             math-rhs (nth 2 (car rules))
  225. X             math-pattern (nth 1 (car rules))))
  226. X          (progn
  227. X        (setq math-conds nil
  228. X              math-pattern (car rules))
  229. X        (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
  230. X                (= (length math-pattern) 3))
  231. X          (let ((cond (nth 2 math-pattern)))
  232. X            (setq math-conds (if math-conds
  233. X                     (list 'calcFunc-land math-conds cond)
  234. X                       cond)
  235. X              math-pattern (nth 1 math-pattern))))
  236. X        (and (eq (car-safe math-pattern) 'calcFunc-assign)
  237. X             (= (length math-pattern) 3)
  238. X             (setq math-rhs (nth 2 math-pattern)
  239. X               math-pattern (nth 1 math-pattern)))))
  240. X      (let* ((math-prog (list nil))
  241. X         (math-prog-last math-prog)
  242. X         (math-num-regs 1)
  243. X         (math-regs (list (list nil 0 nil nil)))
  244. X         (math-bound-vars nil)
  245. X         (math-aliased-vars nil)
  246. X         (math-copy-neg nil))
  247. X        (setq math-conds (and math-conds (math-flatten-lands math-conds)))
  248. X        (math-rwcomp-pattern math-pattern 0)
  249. X        (while math-conds
  250. X          (let ((expr (car math-conds)))
  251. X        (setq math-conds (cdr math-conds))
  252. X        (math-rwcomp-cond-instr expr)))
  253. X        (math-rwcomp-instr 'done
  254. X                   (math-rwcomp-match-vars math-rhs)
  255. X                   math-remembering)
  256. X        (setq math-prog (cdr math-prog))
  257. X        (let* ((heads (math-rewrite-heads math-pattern))
  258. X           (rule (list (vconcat
  259. X                (nreverse
  260. X                 (mapcar (function (lambda (x) (nth 3 x)))
  261. X                     math-regs)))
  262. X                   math-prog
  263. X                   heads
  264. X                   math-phases))
  265. X           (head (and (not (Math-primp math-pattern))
  266. X                  (not (and (eq (car (car math-prog)) 'try)
  267. X                    (nth 5 (car math-prog))))
  268. X                  (not (memq (car (car math-prog)) '(func-opt
  269. X                                 apply
  270. X                                 select
  271. X                                 alt)))
  272. X                  (if (memq (car (car math-prog)) '(func
  273. X                                func-def))
  274. X                  (nth 2 (car math-prog))
  275. X                (if (eq (car math-pattern) 'calcFunc-quote)
  276. X                    (car-safe (nth 1 math-pattern))
  277. X                  (car math-pattern))))))
  278. X          (let (found)
  279. X        (while heads
  280. X          (if (setq found (assq (car heads) all-heads))
  281. X              (setcdr found (1+ (cdr found)))
  282. X            (setq all-heads (cons (cons (car heads) 1) all-heads)))
  283. X          (setq heads (cdr heads))))
  284. X          (if (eq head '-) (setq head '+))
  285. X          (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
  286. X          (if head
  287. X          (progn
  288. X            (nconc (or (assq head rule-set)
  289. X                   (car (setq rule-set (cons (cons head
  290. X                                   (copy-sequence
  291. X                                nil-rules))
  292. X                             rule-set))))
  293. X               (list rule))
  294. X            (if (eq head '*)
  295. X            (nconc (or (assq '/ rule-set)
  296. X                   (car (setq rule-set (cons (cons
  297. X                                  '/
  298. X                                  (copy-sequence
  299. X                                   nil-rules))
  300. X                                 rule-set))))
  301. X                   (list rule))))
  302. X        (setq nil-rules (nconc nil-rules (list rule)))
  303. X        (let ((ptr rule-set))
  304. X          (while ptr
  305. X            (nconc (car ptr) (list rule))
  306. X            (setq ptr (cdr ptr))))))))
  307. X     (t
  308. X      (error "Rewrite rule set must be a vector of A := B rules")))
  309. X    (setq rules (cdr rules)))
  310. X      (if nil-rules
  311. X      (setq rule-set (cons (cons nil nil-rules) rule-set)))
  312. X      (setq all-heads (mapcar 'car
  313. X                  (sort all-heads (function
  314. X                           (lambda (x y)
  315. X                         (< (cdr x) (cdr y)))))))
  316. X      (let ((set rule-set)
  317. X        rule heads ptr)
  318. X    (while set
  319. X      (setq rule (cdr (car set)))
  320. X      (while rule
  321. X        (if (consp (setq heads (nth 2 (car rule))))
  322. X        (progn
  323. X          (setq heads (delq (car (car set)) heads)
  324. X            ptr all-heads)
  325. X          (while (and ptr (not (memq (car ptr) heads)))
  326. X            (setq ptr (cdr ptr)))
  327. X          (setcar (nthcdr 2 (car rule)) (car ptr))))
  328. X        (setq rule (cdr rule)))
  329. X      (setq set (cdr set))))
  330. X      (let ((plus (assq '+ rule-set)))
  331. X    (if plus
  332. X        (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
  333. X      (cons (list 'schedule math-iterations name
  334. X          (or math-schedule
  335. X              (sort math-all-phases '<)
  336. X              (list 1)))
  337. X        rule-set)))
  338. )
  339. X
  340. (defun math-flatten-lands (expr)
  341. X  (if (eq (car-safe expr) 'calcFunc-land)
  342. X      (append (math-flatten-lands (nth 1 expr))
  343. X          (math-flatten-lands (nth 2 expr)))
  344. X    (list expr))
  345. )
  346. X
  347. (defun math-rewrite-heads (expr &optional more all)
  348. X  (let ((heads more)
  349. X    (skips (and (not all)
  350. X            '(calcFunc-apply calcFunc-condition calcFunc-opt
  351. X                     calcFunc-por calcFunc-pnot)))
  352. X    (blanks (and (not all)
  353. X             '(calcFunc-quote calcFunc-plain calcFunc-select
  354. X                      calcFunc-cons calcFunc-rcons
  355. X                      calcFunc-pand))))
  356. X    (or (Math-primp expr)
  357. X    (math-rewrite-heads-rec expr))
  358. X    heads)
  359. )
  360. X
  361. (defun math-rewrite-heads-rec (expr)
  362. X  (or (memq (car expr) skips)
  363. X      (progn
  364. X    (or (memq (car expr) heads)
  365. X        (memq (car expr) blanks)
  366. X        (memq 'algebraic (get (car expr) 'math-rewrite-props))
  367. X        (setq heads (cons (car expr) heads)))
  368. X    (while (setq expr (cdr expr))
  369. X      (or (Math-primp (car expr))
  370. X          (math-rewrite-heads-rec (car expr))))))
  371. )
  372. X
  373. (defun math-parse-schedule (sched)
  374. X  (mapcar (function
  375. X       (lambda (s)
  376. X         (if (integerp s)
  377. X         s
  378. X           (if (math-vectorp s)
  379. X           (math-parse-schedule (cdr s))
  380. X         (if (eq (car-safe s) 'var)
  381. X             (math-var-to-calcFunc s)
  382. X           (error "Improper component in rewrite schedule"))))))
  383. X      sched)
  384. )
  385. X
  386. (defun math-rwcomp-match-vars (expr)
  387. X  (if (Math-primp expr)
  388. X      (if (eq (car-safe expr) 'var)
  389. X      (let ((entry (assq (nth 2 expr) math-regs)))
  390. X        (if entry
  391. X        (math-rwcomp-register-expr (nth 1 entry))
  392. X          expr))
  393. X    expr)
  394. X    (if (and (eq (car expr) 'calcFunc-quote)
  395. X         (= (length expr) 2))
  396. X    (math-rwcomp-match-vars (nth 1 expr))
  397. X      (if (and (eq (car expr) 'calcFunc-plain)
  398. X           (= (length expr) 2)
  399. X           (not (Math-primp (nth 1 expr))))
  400. X      (list (car expr)
  401. X        (cons (car (nth 1 expr))
  402. X              (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
  403. X    (cons (car expr)
  404. X          (mapcar 'math-rwcomp-match-vars (cdr expr))))))
  405. )
  406. X
  407. (defun math-rwcomp-register-expr (num)
  408. X  (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
  409. X    (if (nth 2 entry)
  410. X    (list 'neg (list 'calcFunc-register (nth 1 entry)))
  411. X      (list 'calcFunc-register (nth 1 entry))))
  412. )
  413. X
  414. (defun math-rwcomp-substitute (expr old new)
  415. X  (if (and (eq (car-safe old) 'var)
  416. X       (memq (car-safe new) '(var calcFunc-lambda)))
  417. X      (let ((old-func (math-var-to-calcFunc old))
  418. X        (new-func (math-var-to-calcFunc new)))
  419. X    (math-rwcomp-subst-rec expr))
  420. X    (let ((old-func nil))
  421. X      (math-rwcomp-subst-rec expr)))
  422. )
  423. X
  424. (defun math-rwcomp-subst-rec (expr)
  425. X  (cond ((equal expr old) new)
  426. X    ((Math-primp expr) expr)
  427. X    (t (if (eq (car expr) old-func)
  428. X           (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
  429. X                         (cdr expr)))
  430. X         (cons (car expr)
  431. X           (mapcar 'math-rwcomp-subst-rec (cdr expr))))))
  432. )
  433. X
  434. (setq math-rwcomp-tracing nil)
  435. X
  436. (defun math-rwcomp-trace (instr)
  437. X  (if math-rwcomp-tracing (progn (terpri) (princ instr)))
  438. X  instr
  439. )
  440. X
  441. (defun math-rwcomp-instr (&rest instr)
  442. X  (setcdr math-prog-last
  443. X      (setq math-prog-last (list (math-rwcomp-trace instr))))
  444. )
  445. X
  446. (defun math-rwcomp-multi-instr (tail &rest instr)
  447. X  (setcdr math-prog-last
  448. X      (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
  449. )
  450. X
  451. (defun math-rwcomp-bind-var (reg var)
  452. X  (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
  453. X  (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
  454. X  (math-rwcomp-do-conditions)
  455. )
  456. X
  457. (defun math-rwcomp-unbind-vars (mark)
  458. X  (while (not (eq math-bound-vars mark))
  459. X    (setcar (assq (car math-bound-vars) math-regs) nil)
  460. X    (setq math-bound-vars (cdr math-bound-vars)))
  461. )
  462. X
  463. (defun math-rwcomp-do-conditions ()
  464. X  (let ((cond math-conds))
  465. X    (while cond
  466. X      (if (math-rwcomp-all-regs-done (car cond))
  467. X      (let ((expr (car cond)))
  468. X        (setq math-conds (delq (car cond) math-conds))
  469. X        (setcar cond 1)
  470. X        (math-rwcomp-cond-instr expr)))
  471. X      (setq cond (cdr cond))))
  472. )
  473. X
  474. (defun math-rwcomp-cond-instr (expr)
  475. X  (let (op arg)
  476. X    (cond ((and (eq (car-safe expr) 'calcFunc-matches)
  477. X        (= (length expr) 3)
  478. X        (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
  479. X            'calcFunc-register))
  480. X       (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
  481. X      ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
  482. X       (if (Math-zerop expr)
  483. X           (math-rwcomp-instr 'backtrack)))
  484. X      ((and (eq (car expr) 'calcFunc-let)
  485. X        (= (length expr) 3))
  486. X       (let ((reg (math-rwcomp-reg)))
  487. X         (math-rwcomp-instr 'let reg (nth 2 expr))
  488. X         (math-rwcomp-pattern (nth 1 expr) reg)))
  489. X      ((and (eq (car expr) 'calcFunc-let)
  490. X        (= (length expr) 2)
  491. X        (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
  492. X        (= (length (nth 1 expr)) 3))
  493. X       (let ((reg (math-rwcomp-reg)))
  494. X         (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
  495. X         (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
  496. X      ((and (setq op (cdr (assq (car-safe expr)
  497. X                    '( (calcFunc-integer  . integer)
  498. X                       (calcFunc-real     . real)
  499. X                       (calcFunc-constant . constant)
  500. X                       (calcFunc-negative . negative) ))))
  501. X        (= (length expr) 2)
  502. X        (or (and (eq (car-safe (nth 1 expr)) 'neg)
  503. X             (memq op '(integer real constant))
  504. X             (setq arg (nth 1 (nth 1 expr))))
  505. X            (setq arg (nth 1 expr)))
  506. X        (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
  507. X       (math-rwcomp-instr op (nth 1 arg)))
  508. X      ((and (assq (car-safe expr) calc-tweak-eqn-table)
  509. X        (= (length expr) 3)
  510. X        (eq (car-safe (nth 1 expr)) 'calcFunc-register))
  511. X       (if (math-constp (nth 2 expr))
  512. X           (let ((reg (math-rwcomp-reg)))
  513. X         (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
  514. X         (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
  515. X                    (car expr) reg))
  516. X         (if (eq (car (nth 2 expr)) 'calcFunc-register)
  517. X         (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
  518. X                    (car expr) (nth 1 (nth 2 expr)))
  519. X           (math-rwcomp-instr 'cond expr))))
  520. X      ((and (eq (car-safe expr) 'calcFunc-eq)
  521. X        (= (length expr) 3)
  522. X        (eq (car-safe (nth 1 expr)) '%)
  523. X        (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
  524. X        (math-constp (nth 2 (nth 1 expr)))
  525. X        (math-constp (nth 2 expr)))
  526. X       (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
  527. X                  (nth 2 (nth 1 expr)) (nth 2 expr)))
  528. X      ((equal expr '(var remember var-remember))
  529. X       (setq math-remembering 1))
  530. X      ((and (eq (car-safe expr) 'calcFunc-remember)
  531. X        (= (length expr) 2))
  532. X       (setq math-remembering (if math-remembering
  533. X                      (list 'calcFunc-lor
  534. X                        math-remembering (nth 1 expr))
  535. X                    (nth 1 expr))))
  536. X      (t (math-rwcomp-instr 'cond expr))))
  537. )
  538. X
  539. (defun math-rwcomp-same-instr (reg1 reg2 neg)
  540. X  (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
  541. X                 (nth 2 (math-rwcomp-reg-entry reg2)))
  542. X                 neg)
  543. X             'same-neg
  544. X               'same)
  545. X             reg1 reg2)
  546. )
  547. X
  548. (defun math-rwcomp-copy-instr (reg1 reg2 neg)
  549. X  (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
  550. X          (nth 2 (math-rwcomp-reg-entry reg2)))
  551. X      neg)
  552. X      (math-rwcomp-instr 'copy-neg reg1 reg2)
  553. X    (or (eq reg1 reg2)
  554. X    (math-rwcomp-instr 'copy reg1 reg2)))
  555. )
  556. X
  557. (defun math-rwcomp-reg ()
  558. X  (prog1
  559. X      math-num-regs
  560. X    (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
  561. X      math-num-regs (1+ math-num-regs)))
  562. )
  563. X
  564. (defun math-rwcomp-reg-entry (num)
  565. X  (nth (1- (- math-num-regs num)) math-regs)
  566. )
  567. X
  568. X
  569. (defun math-rwcomp-pattern (expr part &optional not-direct)
  570. X  (cond ((or (math-rwcomp-no-vars expr)
  571. X         (and (eq (car expr) 'calcFunc-quote)
  572. X          (= (length expr) 2)
  573. X          (setq expr (nth 1 expr))))
  574. X      (if (eq (car-safe expr) 'calcFunc-register)
  575. X         (math-rwcomp-same-instr part (nth 1 expr) nil)
  576. X       (let ((reg (math-rwcomp-reg)))
  577. X         (setcar (nthcdr 3 (car math-regs)) expr)
  578. X         (math-rwcomp-same-instr part reg nil))))
  579. X     ((eq (car expr) 'var)
  580. X      (let ((entry (assq (nth 2 expr) math-regs)))
  581. X       (if entry
  582. X           (math-rwcomp-same-instr part (nth 1 entry) nil)
  583. X         (if not-direct
  584. X          (let ((reg (math-rwcomp-reg)))
  585. X           (math-rwcomp-pattern expr reg)
  586. X           (math-rwcomp-copy-instr part reg nil))
  587. X           (if (setq entry (assq (nth 2 expr) math-aliased-vars))
  588. X           (progn
  589. X             (setcar (math-rwcomp-reg-entry (nth 1 entry))
  590. X                 (nth 2 expr))
  591. X             (setcar entry nil)
  592. X             (math-rwcomp-copy-instr part (nth 1 entry) nil))
  593. X          (math-rwcomp-bind-var part expr))))))
  594. X     ((and (eq (car expr) 'calcFunc-select)
  595. X          (= (length expr) 2))
  596. X      (let ((reg (math-rwcomp-reg)))
  597. X       (math-rwcomp-instr 'select part reg)
  598. X       (math-rwcomp-pattern (nth 1 expr) reg)))
  599. X     ((and (eq (car expr) 'calcFunc-opt)
  600. X          (memq (length expr) '(2 3)))
  601. X      (error "opt( ) occurs in context where it is not allowed"))
  602. X     ((eq (car expr) 'neg)
  603. X      (if (eq (car (nth 1 expr)) 'var)
  604. X         (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
  605. X           (if entry
  606. X           (math-rwcomp-same-instr part (nth 1 entry) t)
  607. X         (if math-copy-neg
  608. X             (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
  609. X               (math-rwcomp-copy-instr part reg t)
  610. X               (math-rwcomp-pattern (nth 1 expr) reg))
  611. X           (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
  612. X           (math-rwcomp-pattern (nth 1 expr) part))))
  613. X       (if (math-rwcomp-is-algebraic (nth 1 expr))
  614. X           (math-rwcomp-cond-instr (list 'calcFunc-eq
  615. X                         (math-rwcomp-register-expr part)
  616. X                         expr))
  617. X         (let ((reg (math-rwcomp-reg)))
  618. X           (math-rwcomp-instr 'func part 'neg reg)
  619. X           (math-rwcomp-pattern (nth 1 expr) reg)))))
  620. X     ((and (eq (car expr) 'calcFunc-apply)
  621. X          (= (length expr) 3))
  622. X      (let ((reg1 (math-rwcomp-reg))
  623. X           (reg2 (math-rwcomp-reg)))
  624. X       (math-rwcomp-instr 'apply part reg1 reg2)
  625. X       (math-rwcomp-pattern (nth 1 expr) reg1)
  626. X       (math-rwcomp-pattern (nth 2 expr) reg2)))
  627. X     ((and (eq (car expr) 'calcFunc-cons)
  628. X          (= (length expr) 3))
  629. X      (let ((reg1 (math-rwcomp-reg))
  630. X           (reg2 (math-rwcomp-reg)))
  631. X       (math-rwcomp-instr 'cons part reg1 reg2)
  632. X       (math-rwcomp-pattern (nth 1 expr) reg1)
  633. X       (math-rwcomp-pattern (nth 2 expr) reg2)))
  634. X     ((and (eq (car expr) 'calcFunc-rcons)
  635. X          (= (length expr) 3))
  636. X      (let ((reg1 (math-rwcomp-reg))
  637. X           (reg2 (math-rwcomp-reg)))
  638. X       (math-rwcomp-instr 'rcons part reg1 reg2)
  639. X       (math-rwcomp-pattern (nth 1 expr) reg1)
  640. X       (math-rwcomp-pattern (nth 2 expr) reg2)))
  641. X     ((and (eq (car expr) 'calcFunc-condition)
  642. X          (>= (length expr) 3))
  643. X      (math-rwcomp-pattern (nth 1 expr) part)
  644. X      (setq expr (cdr expr))
  645. X      (while (setq expr (cdr expr))
  646. X       (let ((cond (math-flatten-lands (car expr))))
  647. X         (while cond
  648. X           (if (math-rwcomp-all-regs-done (car cond))
  649. X           (math-rwcomp-cond-instr (car cond))
  650. X          (setq math-conds (cons (car cond) math-conds)))
  651. X           (setq cond (cdr cond))))))
  652. X     ((and (eq (car expr) 'calcFunc-pand)
  653. X          (= (length expr) 3))
  654. X      (math-rwcomp-pattern (nth 1 expr) part)
  655. X      (math-rwcomp-pattern (nth 2 expr) part))
  656. X     ((and (eq (car expr) 'calcFunc-por)
  657. X          (= (length expr) 3))
  658. X      (math-rwcomp-instr 'alt nil nil [nil nil 4])
  659. X      (let ((math-conds nil)
  660. X           (head math-prog-last)
  661. X           (mark math-bound-vars)
  662. X           (math-copy-neg t))
  663. X       (math-rwcomp-pattern (nth 1 expr) part t)
  664. X       (let ((amark math-aliased-vars)
  665. X         (math-aliased-vars math-aliased-vars)
  666. X          (tail math-prog-last)
  667. X         (p math-bound-vars)
  668. X         entry)
  669. X         (while (not (eq p mark))
  670. X           (setq entry (assq (car p) math-regs)
  671. X             math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
  672. X                         math-aliased-vars)
  673. X             p (cdr p))
  674. X           (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
  675. X         (setcar (cdr (car head)) (cdr head))
  676. X         (setcdr head nil)
  677. X         (setq math-prog-last head)
  678. X         (math-rwcomp-pattern (nth 2 expr) part)
  679. X         (math-rwcomp-instr 'same 0 0)
  680. X         (setcdr tail math-prog-last)
  681. X         (setq p math-aliased-vars)
  682. X         (while (not (eq p amark))
  683. X           (if (car (car p))
  684. X           (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
  685. X               (car (car p))))
  686. X           (setq p (cdr p)))))
  687. X      (math-rwcomp-do-conditions))
  688. X     ((and (eq (car expr) 'calcFunc-pnot)
  689. X          (= (length expr) 2))
  690. X      (math-rwcomp-instr 'alt nil nil [nil nil 4])
  691. X      (let ((head math-prog-last)
  692. X           (mark math-bound-vars))
  693. X       (math-rwcomp-pattern (nth 1 expr) part)
  694. X       (math-rwcomp-unbind-vars mark)
  695. X       (math-rwcomp-instr 'end-alt head)
  696. X       (math-rwcomp-instr 'backtrack)
  697. X       (setcar (cdr (car head)) (cdr head))
  698. X       (setcdr head nil)
  699. X       (setq math-prog-last head)))
  700. X     (t (let ((props (get (car expr) 'math-rewrite-props)))
  701. X         (if (and (eq (car expr) 'calcFunc-plain)
  702. X              (= (length expr) 2)
  703. X              (not (math-primp (nth 1 expr))))
  704. X          (setq expr (nth 1 expr))) ; but "props" is still nil
  705. X         (if (and (memq 'algebraic props)
  706. X              (math-rwcomp-is-algebraic expr))
  707. X          (math-rwcomp-cond-instr (list 'calcFunc-eq
  708. X                           (math-rwcomp-register-expr part)
  709. X                           expr))
  710. X           (if (and (memq 'commut props)
  711. X             (= (length expr) 3))
  712. X           (let ((arg1 (nth 1 expr))
  713. X              (arg2 (nth 2 expr))
  714. X              try1 def code head (flip nil))
  715. X             (if (eq (car expr) '-)
  716. X              (setq arg2 (math-rwcomp-neg arg2)))
  717. X             (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
  718. X               arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
  719. X             (or (math-rwcomp-order arg1 arg2)
  720. X              (setq def arg1 arg1 arg2 arg2 def flip t))
  721. X             (if (math-rwcomp-optional-arg (car expr) arg1)
  722. X              (error "Too many opt( ) arguments in this context"))
  723. X             (setq def (math-rwcomp-optional-arg (car expr) arg2)
  724. X               head (if (memq (car expr) '(+ -))
  725. X                    '(+ -)
  726. X                  (if (eq (car expr) '*)
  727. X                      '(* /)
  728. X                    (list (car expr))))
  729. X               code (if (math-rwcomp-is-constrained
  730. X                     (car arg1) head)
  731. X                    (if (math-rwcomp-is-constrained
  732. X                      (car arg2) head)
  733. X                     0 1)
  734. X                  2))
  735. X             (math-rwcomp-multi-instr (and def (list def))
  736. X                          'try part head
  737. X                          (vector nil nil nil code flip)
  738. X                          (cdr arg1))
  739. X             (setq try1 (car math-prog-last))
  740. X             (math-rwcomp-pattern (car arg1) (cdr arg1))
  741. X             (math-rwcomp-instr 'try2 try1 (cdr arg2))
  742. X             (if (and (= part 0) (not def) (not math-rewrite-whole)
  743. X                   (setq def (get (car expr)
  744. X                          'math-rewrite-default)))
  745. X              (let ((reg1 (math-rwcomp-reg))
  746. X                    (reg2 (math-rwcomp-reg)))
  747. X                (if (= (aref (nth 3 try1) 3) 0)
  748. X                    (aset (nth 3 try1) 3 1))
  749. X               (math-rwcomp-instr 'try (cdr arg2)
  750. X                          (if (equal head '(* /))
  751. X                          '(*) head)
  752. X                           (vector nil nil nil
  753. X                               (if (= code 0)
  754. X                               1 2)
  755. X                               nil)
  756. X                           reg1 def)
  757. X                (setq try1 (car math-prog-last))
  758. X                (math-rwcomp-pattern (car arg2) reg1)
  759. X                (math-rwcomp-instr 'try2 try1 reg2)
  760. X                (setq math-rhs (list (if (eq (car expr) '-)
  761. X                             '+ (car expr))
  762. X                         math-rhs
  763. X                         (list 'calcFunc-register
  764. X                               reg2))))
  765. X                (math-rwcomp-pattern (car arg2) (cdr arg2))))
  766. X          (let* ((args (mapcar (function
  767. X                        (lambda (x)
  768. X                      (cons x (math-rwcomp-best-reg x))))
  769. X                       (cdr expr)))
  770. X             (args2 (copy-sequence args))
  771. X             (argp (reverse args2))
  772. X             (defs nil)
  773. X             (num 1))
  774. X            (while argp
  775. X              (let ((def (math-rwcomp-optional-arg (car expr)
  776. X                               (car argp))))
  777. X                (if def
  778. X                (progn
  779. X                  (setq args2 (delq (car argp) args2)
  780. X                    defs (cons (cons def (cdr (car argp)))
  781. X                           defs))
  782. X                  (math-rwcomp-multi-instr
  783. X                   (mapcar 'cdr args2)
  784. X                   (if (or (and (memq 'unary1 props)
  785. X                        (= (length args2) 1)
  786. X                        (eq (car args2) (car args)))
  787. X                       (and (memq 'unary2 props)
  788. X                        (= (length args) 2)
  789. X                        (eq (car args2) (nth 1 args))))
  790. X                   'func-opt
  791. X                 'func-def)
  792. X                   part (car expr)
  793. X                   defs))))
  794. X              (setq argp (cdr argp)))
  795. X            (math-rwcomp-multi-instr (mapcar 'cdr args)
  796. X                         'func part (car expr))
  797. X            (setq args (sort args 'math-rwcomp-order))
  798. X            (while args
  799. X              (math-rwcomp-pattern (car (car args)) (cdr (car args)))
  800. X              (setq num (1+ num)
  801. X                args (cdr args)))))))))
  802. )
  803. X
  804. (defun math-rwcomp-best-reg (x)
  805. X  (or (and (eq (car-safe x) 'var)
  806. X       (let ((entry (assq (nth 2 x) math-aliased-vars)))
  807. X         (and entry
  808. X          (not (nth 2 entry))
  809. X          (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
  810. X          (progn
  811. X            (setcar (cdr (cdr entry)) t)
  812. X            (nth 1 entry)))))
  813. X      (math-rwcomp-reg))
  814. )
  815. X
  816. (defun math-rwcomp-all-regs-done (expr)
  817. X  (if (Math-primp expr)
  818. X      (or (not (eq (car-safe expr) 'var))
  819. X      (assq (nth 2 expr) math-regs)
  820. X      (eq (nth 2 expr) 'var-remember)
  821. X      (math-const-var expr))
  822. X    (if (and (eq (car expr) 'calcFunc-let)
  823. X         (= (length expr) 3))
  824. X    (math-rwcomp-all-regs-done (nth 2 expr))
  825. X      (if (and (eq (car expr) 'calcFunc-let)
  826. X           (= (length expr) 2)
  827. X           (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
  828. X           (= (length (nth 1 expr)) 3))
  829. X      (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
  830. X    (while (and (setq expr (cdr expr))
  831. X            (math-rwcomp-all-regs-done (car expr))))
  832. X    (null expr))))
  833. )
  834. X
  835. (defun math-rwcomp-no-vars (expr)
  836. X  (if (Math-primp expr)
  837. X      (or (not (eq (car-safe expr) 'var))
  838. X      (math-const-var expr))
  839. X    (and (not (memq (car expr) '(calcFunc-condition
  840. X                 calcFunc-select calcFunc-quote
  841. X                 calcFunc-plain calcFunc-opt
  842. X                 calcFunc-por calcFunc-pand
  843. X                 calcFunc-pnot calcFunc-apply
  844. X                 calcFunc-cons calcFunc-rcons)))
  845. X     (progn
  846. X       (while (and (setq expr (cdr expr))
  847. X               (math-rwcomp-no-vars (car expr))))
  848. X       (null expr))))
  849. )
  850. X
  851. (defun math-rwcomp-is-algebraic (expr)
  852. X  (if (Math-primp expr)
  853. X      (or (not (eq (car-safe expr) 'var))
  854. X      (math-const-var expr)
  855. X      (assq (nth 2 expr) math-regs))
  856. X    (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
  857. X     (progn
  858. X       (while (and (setq expr (cdr expr))
  859. X               (math-rwcomp-is-algebraic (car expr))))
  860. X       (null expr))))
  861. )
  862. X
  863. (defun math-rwcomp-is-constrained (expr not-these)
  864. X  (if (Math-primp expr)
  865. X      (not (eq (car-safe expr) 'var))
  866. X    (if (eq (car expr) 'calcFunc-plain)
  867. X    (math-rwcomp-is-constrained (nth 1 expr) not-these)
  868. X      (not (or (memq (car expr) '(neg calcFunc-select))
  869. X           (memq (car expr) not-these)
  870. X           (and (memq 'commut (get (car expr) 'math-rewrite-props))
  871. X            (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
  872. X            (eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
  873. )
  874. X
  875. (defun math-rwcomp-optional-arg (head argp)
  876. X  (let ((arg (car argp)))
  877. X    (if (eq (car-safe arg) 'calcFunc-opt)
  878. X    (and (memq (length arg) '(2 3))
  879. X         (progn
  880. X           (or (eq (car-safe (nth 1 arg)) 'var)
  881. X           (error "First argument of opt( ) must be a variable"))
  882. X           (setcar argp (nth 1 arg))
  883. X           (if (= (length arg) 2)
  884. X           (or (get head 'math-rewrite-default)
  885. X               (error "opt( ) must include a default in this context"))
  886. X         (nth 2 arg))))
  887. X      (and (eq (car-safe arg) 'neg)
  888. X       (let* ((part (list (nth 1 arg)))
  889. X          (partp (math-rwcomp-optional-arg head part)))
  890. X         (and partp
  891. X          (setcar argp (math-rwcomp-neg (car part)))
  892. X          (math-neg partp))))))
  893. )
  894. X
  895. (defun math-rwcomp-neg (expr)
  896. X  (if (memq (car-safe expr) '(* /))
  897. X      (if (eq (car-safe (nth 1 expr)) 'var)
  898. X      (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
  899. X    (if (eq (car-safe (nth 2 expr)) 'var)
  900. X        (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
  901. X      (math-neg expr)))
  902. X    (math-neg expr))
  903. )
  904. X
  905. (defun math-rwcomp-assoc-args (expr)
  906. X  (if (and (eq (car-safe (nth 1 expr)) (car expr))
  907. X       (= (length (nth 1 expr)) 3))
  908. X      (math-rwcomp-assoc-args (nth 1 expr))
  909. X    (setq math-args (cons (nth 1 expr) math-args)))
  910. X  (if (and (eq (car-safe (nth 2 expr)) (car expr))
  911. X       (= (length (nth 2 expr)) 3))
  912. X      (math-rwcomp-assoc-args (nth 2 expr))
  913. X    (setq math-args (cons (nth 2 expr) math-args)))
  914. )
  915. X
  916. (defun math-rwcomp-addsub-args (expr)
  917. X  (if (memq (car-safe (nth 1 expr)) '(+ -))
  918. X      (math-rwcomp-addsub-args (nth 1 expr))
  919. X    (setq math-args (cons (nth 1 expr) math-args)))
  920. X  (if (eq (car expr) '-)
  921. X      (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
  922. X    (if (eq (car-safe (nth 2 expr)) '+)
  923. X    (math-rwcomp-addsub-args (nth 2 expr))
  924. X      (setq math-args (cons (nth 2 expr) math-args))))
  925. )
  926. X
  927. (defun math-rwcomp-order (a b)
  928. X  (< (math-rwcomp-priority (car a))
  929. X     (math-rwcomp-priority (car b)))
  930. )
  931. X
  932. ;;; Order of priority:    0 Constants and other exact matches (first)
  933. ;;;                      10 Functions (except below)
  934. ;;;             20 Meta-variables which occur more than once
  935. ;;;             30 Algebraic functions
  936. ;;;             40 Commutative/associative functions
  937. ;;;             50 Meta-variables which occur only once
  938. ;;;               +100 for every "!!!" (pnot) in the pattern
  939. ;;;              10000 Optional arguments (last)
  940. X
  941. (defun math-rwcomp-priority (expr)
  942. X  (+ (math-rwcomp-count-pnots expr)
  943. X     (cond ((eq (car-safe expr) 'calcFunc-opt)
  944. X        10000)
  945. X       ((math-rwcomp-no-vars expr)
  946. X        0)
  947. X       ((eq (car expr) 'calcFunc-quote)
  948. X        0)
  949. X       ((eq (car expr) 'var)
  950. X        (if (assq (nth 2 expr) math-regs)
  951. X        0
  952. X          (if (= (math-rwcomp-count-refs expr) 1)
  953. X          50
  954. X        20)))
  955. X       (t (let ((props (get (car expr) 'math-rewrite-props)))
  956. X        (if (or (memq 'commut props)
  957. X            (memq 'assoc props))
  958. X            40
  959. X          (if (memq 'algebraic props)
  960. X              30
  961. X            10))))))
  962. )
  963. X
  964. (defun math-rwcomp-count-refs (var)
  965. X  (let ((count (or (math-expr-contains-count math-pattern var) 0))
  966. X    (p math-conds))
  967. X    (while p
  968. X      (if (eq (car-safe (car p)) 'calcFunc-let)
  969. X      (if (= (length (car p)) 3)
  970. X          (setq count (+ count
  971. X                 (or (math-expr-contains-count (nth 2 (car p)) var)
  972. X                 0)))
  973. X        (if (and (= (length (car p)) 2)
  974. X             (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
  975. X             (= (length (nth 1 (car p))) 3))
  976. X        (setq count (+ count
  977. X                   (or (math-expr-contains-count
  978. X                    (nth 2 (nth 1 (car p))) var) 0))))))
  979. X      (setq p (cdr p)))
  980. X    count)
  981. )
  982. X
  983. (defun math-rwcomp-count-pnots (expr)
  984. X  (if (Math-primp expr)
  985. X      0
  986. X    (if (eq (car expr) 'calcFunc-pnot)
  987. X    100
  988. X      (let ((count 0))
  989. X    (while (setq expr (cdr expr))
  990. X      (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
  991. X    count)))
  992. )
  993. X
  994. ;;; In the current implementation, all associative functions must
  995. ;;; also be commutative.
  996. X
  997. (put '+             'math-rewrite-props '(algebraic assoc commut))
  998. (put '-             'math-rewrite-props '(algebraic assoc commut)) ; see below
  999. (put '*             'math-rewrite-props '(algebraic assoc commut)) ; see below
  1000. (put '/             'math-rewrite-props '(algebraic unary1))
  1001. (put '^             'math-rewrite-props '(algebraic unary1))
  1002. (put '%             'math-rewrite-props '(algebraic))
  1003. (put 'neg         'math-rewrite-props '(algebraic))
  1004. (put 'calcFunc-idiv  'math-rewrite-props '(algebraic))
  1005. (put 'calcFunc-abs   'math-rewrite-props '(algebraic))
  1006. (put 'calcFunc-sign  'math-rewrite-props '(algebraic))
  1007. (put 'calcFunc-round 'math-rewrite-props '(algebraic))
  1008. (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
  1009. (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
  1010. (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
  1011. (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
  1012. (put 'calcFunc-ceil  'math-rewrite-props '(algebraic))
  1013. (put 'calcFunc-re    'math-rewrite-props '(algebraic))
  1014. (put 'calcFunc-im    'math-rewrite-props '(algebraic))
  1015. (put 'calcFunc-conj  'math-rewrite-props '(algebraic))
  1016. (put 'calcFunc-arg   'math-rewrite-props '(algebraic))
  1017. (put 'calcFunc-and   'math-rewrite-props '(assoc commut))
  1018. (put 'calcFunc-or    'math-rewrite-props '(assoc commut))
  1019. (put 'calcFunc-xor   'math-rewrite-props '(assoc commut))
  1020. (put 'calcFunc-eq    'math-rewrite-props '(commut))
  1021. (put 'calcFunc-neq   'math-rewrite-props '(commut))
  1022. (put 'calcFunc-land  'math-rewrite-props '(assoc commut))
  1023. (put 'calcFunc-lor   'math-rewrite-props '(assoc commut))
  1024. (put 'calcFunc-beta  'math-rewrite-props '(commut))
  1025. (put 'calcFunc-gcd   'math-rewrite-props '(assoc commut))
  1026. (put 'calcFunc-lcm   'math-rewrite-props '(assoc commut))
  1027. (put 'calcFunc-max   'math-rewrite-props '(algebraic assoc commut))
  1028. (put 'calcFunc-min   'math-rewrite-props '(algebraic assoc commut))
  1029. (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
  1030. (put 'calcFunc-vint  'math-rewrite-props '(assoc commut))
  1031. (put 'calcFunc-vxor  'math-rewrite-props '(assoc commut))
  1032. X
  1033. ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
  1034. ;;; Also, "-" is not commutative but the code tweaks things so that it is.
  1035. X
  1036. (put '+             'math-rewrite-default  0)
  1037. (put '-             'math-rewrite-default  0)
  1038. (put '*             'math-rewrite-default  1)
  1039. (put '/             'math-rewrite-default  1)
  1040. (put '^             'math-rewrite-default  1)
  1041. (put 'calcFunc-land  'math-rewrite-default  1)
  1042. (put 'calcFunc-lor   'math-rewrite-default  0)
  1043. (put 'calcFunc-vunion 'math-rewrite-default '(vec))
  1044. (put 'calcFunc-vint  'math-rewrite-default '(vec))
  1045. (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
  1046. (put 'calcFunc-vxor  'math-rewrite-default '(vec))
  1047. X
  1048. (defmacro math-rwfail (&optional back)
  1049. X  (list 'setq 'pc
  1050. X    (list 'and
  1051. X          (if back
  1052. X          '(setq btrack (cdr btrack))
  1053. X        'btrack)
  1054. X          ''((backtrack))))
  1055. )
  1056. X
  1057. ;;; This monstrosity is necessary because the use of static vectors of
  1058. ;;; registers makes rewrite rules non-reentrant.  Yucko!
  1059. (defmacro math-rweval (form)
  1060. X  (list 'let '((orig (car rules)))
  1061. X    '(setcar rules (quote (nil nil nil no-phase)))
  1062. X    (list 'unwind-protect
  1063. X          form
  1064. X          '(setcar rules orig)))
  1065. )
  1066. X
  1067. (setq math-rewrite-phase 1)
  1068. X
  1069. (defun math-apply-rewrites (expr rules &optional heads ruleset)
  1070. X  (and
  1071. X   (setq rules (cdr (or (assq (car-safe expr) rules)
  1072. X            (assq nil rules))))
  1073. X   (let ((result nil)
  1074. X     op regs inst part pc mark btrack
  1075. X     (tracing math-rwcomp-tracing)
  1076. X     (phase math-rewrite-phase))
  1077. X     (while rules
  1078. X       (or
  1079. X    (and (setq part (nth 2 (car rules)))
  1080. X         heads
  1081. X         (not (memq part heads)))
  1082. X    (and (setq part (nth 3 (car rules)))
  1083. X         (not (memq phase part)))
  1084. X    (progn
  1085. X      (setq regs (car (car rules))
  1086. X        pc (nth 1 (car rules))
  1087. X        btrack nil)
  1088. X      (aset regs 0 expr)
  1089. X      (while pc
  1090. X         
  1091. X        (and tracing
  1092. X         (progn (terpri) (princ (car pc))
  1093. X            (if (and (natnump (nth 1 (car pc)))
  1094. X                 (< (nth 1 (car pc)) (length regs)))
  1095. X                (princ (format "\n  part = %s"
  1096. X                       (aref regs (nth 1 (car pc))))))))
  1097. X        
  1098. X        (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
  1099. X           (if (and (consp (setq part (aref regs (car (cdr inst)))))
  1100. X                (eq (car part)
  1101. X                (car (setq inst (cdr (cdr inst)))))
  1102. X                (progn
  1103. X                  (while (and (setq inst (cdr inst)
  1104. X                        part (cdr part))
  1105. X                      inst)
  1106. X                (aset regs (car inst) (car part)))
  1107. X                  (not (or inst part))))
  1108. X               (setq pc (cdr pc))
  1109. X             (math-rwfail)))
  1110. X          
  1111. X          ((eq op 'same)
  1112. X           (if (or (equal (setq part (aref regs (nth 1 inst)))
  1113. X                  (setq mark (aref regs (nth 2 inst))))
  1114. X               (Math-equal part mark))
  1115. X               (setq pc (cdr pc))
  1116. X             (math-rwfail)))
  1117. X          
  1118. X          ((and (eq op 'try)
  1119. X            calc-matrix-mode
  1120. X            (not (eq calc-matrix-mode 'scalar))
  1121. X            (eq (car (nth 2 inst)) '*)
  1122. X            (consp (setq part (aref regs (car (cdr inst)))))
  1123. X            (eq (car part) '*)
  1124. X            (not (math-known-scalarp part)))
  1125. X           (setq mark (nth 3 inst)
  1126. X             pc (cdr pc))
  1127. X           (if (aref mark 4)
  1128. X               (progn
  1129. X             (aset regs (nth 4 inst) (nth 2 part))
  1130. X             (aset mark 1 (cdr (cdr part))))
  1131. X             (aset regs (nth 4 inst) (nth 1 part))
  1132. X             (aset mark 1 (cdr part)))
  1133. X           (aset mark 0 (cdr part))
  1134. X           (aset mark 2 0))
  1135. X          
  1136. X          ((eq op 'try)
  1137. X           (if (and (consp (setq part (aref regs (car (cdr inst)))))
  1138. X                (memq (car part) (nth 2 inst))
  1139. X                (= (length part) 3)
  1140. X                (or (not (eq (car part) '/))
  1141. X                (Math-objectp (nth 2 part))))
  1142. X               (progn
  1143. X             (setq op nil
  1144. X                   mark (car (cdr (setq inst (cdr (cdr inst))))))
  1145. X             (and
  1146. X              (memq 'assoc (get (car part) 'math-rewrite-props))
  1147. X              (not (= (aref mark 3) 0))
  1148. X              (while (if (and (consp (nth 1 part))
  1149. X                      (memq (car (nth 1 part)) (car inst)))
  1150. X                     (setq op (cons (if (eq (car part) '-)
  1151. X                            (math-rwapply-neg
  1152. X                             (nth 2 part))
  1153. X                              (nth 2 part))
  1154. X                            op)
  1155. X                       part (nth 1 part))
  1156. X                   (if (and (consp (nth 2 part))
  1157. X                        (memq (car (nth 2 part))
  1158. X                          (car inst))
  1159. X                        (not (eq (car (nth 2 part)) '-)))
  1160. X                       (setq op (cons (nth 1 part) op)
  1161. X                         part (nth 2 part))))))
  1162. X             (setq op (cons (nth 1 part)
  1163. X                    (cons (if (eq (car part) '-)
  1164. X                          (math-rwapply-neg
  1165. X                           (nth 2 part))
  1166. X                        (if (eq (car part) '/)
  1167. X                            (math-rwapply-inv
  1168. X                             (nth 2 part))
  1169. X                          (nth 2 part)))
  1170. X                          op))
  1171. X                   btrack (cons pc btrack)
  1172. X                   pc (cdr pc))
  1173. X             (aset regs (nth 2 inst) (car op))
  1174. X             (aset mark 0 op)
  1175. X             (aset mark 1 op)
  1176. X             (aset mark 2 (if (cdr (cdr op)) 1 0)))
  1177. X             (if (nth 5 inst)
  1178. X             (if (and (consp part)
  1179. X                  (eq (car part) 'neg)
  1180. X                  (eq (car (nth 2 inst)) '*)
  1181. X                  (eq (nth 5 inst) 1))
  1182. X                 (progn
  1183. X                   (setq mark (nth 3 inst)
  1184. X                     pc (cdr pc))
  1185. X                   (aset regs (nth 4 inst) (nth 1 part))
  1186. X                   (aset mark 1 -1)
  1187. X                   (aset mark 2 4))
  1188. X               (setq mark (nth 3 inst)
  1189. X                 pc (cdr pc))
  1190. X               (aset regs (nth 4 inst) part)
  1191. X               (aset mark 2 3))
  1192. X               (math-rwfail))))
  1193. X          
  1194. X          ((eq op 'try2)
  1195. X           (setq part (nth 1 inst)   ; try instr
  1196. X             mark (nth 3 part)
  1197. X             op (aref mark 2)
  1198. X             pc (cdr pc))
  1199. X           (aset regs (nth 2 inst)
  1200. X             (cond
  1201. X              ((eq op 0)
  1202. X               (if (eq (aref mark 0) (aref mark 1))
  1203. X                   (nth 1 (aref mark 0))
  1204. X                 (car (aref mark 0))))
  1205. X              ((eq op 1)
  1206. X               (setq mark (delq (car (aref mark 1))
  1207. X                        (copy-sequence (aref mark 0)))
  1208. X                 op (car (nth 2 part)))
  1209. X               (if (eq op '*)
  1210. X                   (progn
  1211. X                 (setq mark (nreverse mark)
  1212. X                       part (list '* (nth 1 mark) (car mark))
  1213. X                       mark (cdr mark))
  1214. X                 (while (setq mark (cdr mark))
  1215. X                   (setq part (list '* (car mark) part))))
  1216. X                 (setq part (car mark)
  1217. X                   mark (cdr mark)
  1218. X                   part (if (and (eq op '+)
  1219. X                         (consp (car mark))
  1220. X                         (eq (car (car mark)) 'neg))
  1221. X                        (list '- part
  1222. X                          (nth 1 (car mark)))
  1223. X                      (list op part (car mark))))
  1224. X                 (while (setq mark (cdr mark))
  1225. X                   (setq part (if (and (eq op '+)
  1226. X                           (consp (car mark))
  1227. X                           (eq (car (car mark)) 'neg))
  1228. X                          (list '- part
  1229. X                            (nth 1 (car mark)))
  1230. X                        (list op part (car mark))))))
  1231. X               part)
  1232. X              ((eq op 2)
  1233. X               (car (aref mark 1)))
  1234. X              ((eq op 3) (nth 5 part))
  1235. X              (t (aref mark 1)))))
  1236. X          
  1237. X          ((eq op 'select)
  1238. X           (setq pc (cdr pc))
  1239. X           (if (and (consp (setq part (aref regs (nth 1 inst))))
  1240. X                (eq (car part) 'calcFunc-select))
  1241. X               (aset regs (nth 2 inst) (nth 1 part))
  1242. X             (if math-rewrite-selections
  1243. X             (math-rwfail)
  1244. X               (aset regs (nth 2 inst) part))))
  1245. X          
  1246. X          ((eq op 'same-neg)
  1247. X           (if (or (equal (setq part (aref regs (nth 1 inst)))
  1248. X                  (setq mark (math-neg
  1249. X                          (aref regs (nth 2 inst)))))
  1250. X               (Math-equal part mark))
  1251. X               (setq pc (cdr pc))
  1252. X             (math-rwfail)))
  1253. X          
  1254. X          ((eq op 'backtrack)
  1255. X           (setq inst (car (car btrack))   ; "try" or "alt" instr
  1256. X             pc (cdr (car btrack))
  1257. X             mark (or (nth 3 inst) [nil nil 4])
  1258. X             op (aref mark 2))
  1259. X           (cond ((eq op 0)
  1260. X              (if (setq op (cdr (aref mark 1)))
  1261. X                  (aset regs (nth 4 inst) (car (aset mark 1 op)))
  1262. X                (if (nth 5 inst)
  1263. X                (progn
  1264. X                  (aset mark 2 3)
  1265. X                  (aset regs (nth 4 inst)
  1266. X                    (aref regs (nth 1 inst))))
  1267. X                  (math-rwfail t))))
  1268. X             ((eq op 1)
  1269. X              (if (setq op (cdr (aref mark 1)))
  1270. X                  (aset regs (nth 4 inst) (car (aset mark 1 op)))
  1271. X                (if (= (aref mark 3) 1)
  1272. X                (if (nth 5 inst)
  1273. X                    (progn
  1274. X                      (aset mark 2 3)
  1275. X                      (aset regs (nth 4 inst)
  1276. X                        (aref regs (nth 1 inst))))
  1277. X                  (math-rwfail t))
  1278. X                  (aset mark 2 2)
  1279. X                  (aset mark 1 (cons nil (aref mark 0)))
  1280. X                  (math-rwfail))))
  1281. X             ((eq op 2)
  1282. X              (if (setq op (cdr (aref mark 1)))
  1283. X                  (progn
  1284. X                (setq mark (delq (car (aset mark 1 op))
  1285. X                         (copy-sequence
  1286. X                          (aref mark 0)))
  1287. X                      op (car (nth 2 inst)))
  1288. X                (if (eq op '*)
  1289. X                    (progn
  1290. X                      (setq mark (nreverse mark)
  1291. X                        part (list '* (nth 1 mark)
  1292. X                               (car mark))
  1293. X                        mark (cdr mark))
  1294. X                      (while (setq mark (cdr mark))
  1295. X                    (setq part (list '* (car mark)
  1296. X                             part))))
  1297. X                  (setq part (car mark)
  1298. X                    mark (cdr mark)
  1299. X                    part (if (and (eq op '+)
  1300. X                              (consp (car mark))
  1301. X                              (eq (car (car mark))
  1302. X                              'neg))
  1303. X                         (list '- part
  1304. X                               (nth 1 (car mark)))
  1305. X                           (list op part (car mark))))
  1306. X                  (while (setq mark (cdr mark))
  1307. X                    (setq part (if (and (eq op '+)
  1308. X                            (consp (car mark))
  1309. X                            (eq (car (car mark))
  1310. X                                'neg))
  1311. X                           (list '- part
  1312. X                             (nth 1 (car mark)))
  1313. X                         (list op part (car mark))))))
  1314. X                (aset regs (nth 4 inst) part))
  1315. X                (if (nth 5 inst)
  1316. X                (progn
  1317. X                  (aset mark 2 3)
  1318. X                  (aset regs (nth 4 inst)
  1319. X                    (aref regs (nth 1 inst))))
  1320. X                  (math-rwfail t))))
  1321. X             ((eq op 4)
  1322. X              (setq btrack (cdr btrack)))
  1323. X             (t (math-rwfail t))))
  1324. X          
  1325. X          ((eq op 'integer)
  1326. X           (if (Math-integerp (setq part (aref regs (nth 1 inst))))
  1327. X               (setq pc (cdr pc))
  1328. X             (if (Math-primp part)
  1329. X             (math-rwfail)
  1330. X               (setq part (math-rweval (math-simplify part)))
  1331. X               (if (Math-integerp part)
  1332. X               (setq pc (cdr pc))
  1333. X             (math-rwfail)))))
  1334. X          
  1335. X          ((eq op 'real)
  1336. X           (if (Math-realp (setq part (aref regs (nth 1 inst))))
  1337. X               (setq pc (cdr pc))
  1338. X             (if (Math-primp part)
  1339. X             (math-rwfail)
  1340. X               (setq part (math-rweval (math-simplify part)))
  1341. X               (if (Math-realp part)
  1342. X               (setq pc (cdr pc))
  1343. X             (math-rwfail)))))
  1344. X          
  1345. X          ((eq op 'constant)
  1346. X           (if (math-constp (setq part (aref regs (nth 1 inst))))
  1347. X               (setq pc (cdr pc))
  1348. X             (if (Math-primp part)
  1349. X             (math-rwfail)
  1350. X               (setq part (math-rweval (math-simplify part)))
  1351. X               (if (math-constp part)
  1352. X               (setq pc (cdr pc))
  1353. X             (math-rwfail)))))
  1354. X          
  1355. X          ((eq op 'negative)
  1356. X           (if (math-looks-negp (setq part (aref regs (nth 1 inst))))
  1357. X               (setq pc (cdr pc))
  1358. X             (if (Math-primp part)
  1359. X             (math-rwfail)
  1360. X               (setq part (math-rweval (math-simplify part)))
  1361. X               (if (math-looks-negp part)
  1362. X               (setq pc (cdr pc))
  1363. X             (math-rwfail)))))
  1364. X          
  1365. X          ((eq op 'rel)
  1366. X           (setq part (math-compare (aref regs (nth 1 inst))
  1367. X                        (aref regs (nth 3 inst)))
  1368. X             op (nth 2 inst))
  1369. X           (if (= part 2)
  1370. X               (setq part (math-rweval
  1371. X                   (math-simplify
  1372. X                    (calcFunc-sign
  1373. X                     (math-sub (aref regs (nth 1 inst))
  1374. X                           (aref regs (nth 3 inst))))))))
  1375. X           (if (cond ((eq op 'calcFunc-eq)
  1376. X                  (eq part 0))
  1377. X                 ((eq op 'calcFunc-neq)
  1378. X                  (memq part '(-1 1)))
  1379. X                 ((eq op 'calcFunc-lt)
  1380. X                  (eq part -1))
  1381. X                 ((eq op 'calcFunc-leq)
  1382. X                  (memq part '(-1 0)))
  1383. X                 ((eq op 'calcFunc-gt)
  1384. X                  (eq part 1))
  1385. X                 ((eq op 'calcFunc-geq)
  1386. X                  (memq part '(0 1))))
  1387. X               (setq pc (cdr pc))
  1388. X             (math-rwfail)))
  1389. X          
  1390. X          ((eq op 'func-def)
  1391. X           (if (and (consp (setq part (aref regs (car (cdr inst)))))
  1392. X                (eq (car part)
  1393. X                (car (setq inst (cdr (cdr inst))))))
  1394. X               (progn
  1395. X             (setq inst (cdr inst)
  1396. X                   mark (car inst))
  1397. X             (while (and (setq inst (cdr inst)
  1398. X                       part (cdr part))
  1399. X                     inst)
  1400. X               (aset regs (car inst) (car part)))
  1401. X             (if (or inst part)
  1402. X                 (setq pc (cdr pc))
  1403. X               (while (eq (car (car (setq pc (cdr pc))))
  1404. X                      'func-def))
  1405. X               (setq pc (cdr pc))   ; skip over "func"
  1406. X               (while mark
  1407. X                 (aset regs (cdr (car mark)) (car (car mark)))
  1408. X                 (setq mark (cdr mark)))))
  1409. X             (math-rwfail)))
  1410. X
  1411. X          ((eq op 'func-opt)
  1412. X           (if (or (not (and (consp
  1413. X                      (setq part (aref regs (car (cdr inst)))))
  1414. X                     (eq (car part) (nth 2 inst))))
  1415. X               (and (= (length part) 2)
  1416. X                (setq part (nth 1 part))))
  1417. X               (progn
  1418. X             (setq mark (nth 3 inst))
  1419. X             (aset regs (nth 4 inst) part)
  1420. X             (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
  1421. X             (setq pc (cdr pc))   ; skip over "func"
  1422. X             (while mark
  1423. X               (aset regs (cdr (car mark)) (car (car mark)))
  1424. X               (setq mark (cdr mark))))
  1425. X             (setq pc (cdr pc))))
  1426. X
  1427. X          ((eq op 'mod)
  1428. X           (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
  1429. X               (Math-zerop (nth 3 inst))
  1430. X             (and (not (Math-zerop (nth 2 inst)))
  1431. X                  (progn
  1432. X                (setq part (math-mod part (nth 2 inst)))
  1433. X                (or (Math-numberp part)
  1434. X                    (setq part (math-rweval
  1435. X                        (math-simplify part))))
  1436. X                (Math-equal part (nth 3 inst)))))
  1437. X               (setq pc (cdr pc))
  1438. X             (math-rwfail)))
  1439. X
  1440. X          ((eq op 'apply)
  1441. X           (if (and (consp (setq part (aref regs (car (cdr inst)))))
  1442. X                (not (Math-objvecp part))
  1443. X                (not (eq (car part) 'var)))
  1444. X               (progn
  1445. X             (aset regs (nth 2 inst)
  1446. X                   (math-calcFunc-to-var (car part)))
  1447. X             (aset regs (nth 3 inst)
  1448. X                   (cons 'vec (cdr part)))
  1449. X             (setq pc (cdr pc)))
  1450. X             (math-rwfail)))
  1451. X
  1452. X          ((eq op 'cons)
  1453. X           (if (and (consp (setq part (aref regs (car (cdr inst)))))
  1454. X                (eq (car part) 'vec)
  1455. X                (cdr part))
  1456. X               (progn
  1457. X             (aset regs (nth 2 inst) (nth 1 part))
  1458. X             (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
  1459. X             (setq pc (cdr pc)))
  1460. X             (math-rwfail)))
  1461. X
  1462. X          ((eq op 'rcons)
  1463. X           (if (and (consp (setq part (aref regs (car (cdr inst)))))
  1464. X                (eq (car part) 'vec)
  1465. X                (cdr part))
  1466. X               (progn
  1467. X             (aset regs (nth 2 inst) (calcFunc-rhead part))
  1468. X             (aset regs (nth 3 inst) (calcFunc-rtail part))
  1469. X             (setq pc (cdr pc)))
  1470. X             (math-rwfail)))
  1471. X
  1472. X          ((eq op 'cond)
  1473. X           (if (math-is-true
  1474. X            (math-rweval
  1475. X             (math-simplify
  1476. X              (math-rwapply-replace-regs (nth 1 inst)))))
  1477. X               (setq pc (cdr pc))
  1478. X             (math-rwfail)))
  1479. X          
  1480. X          ((eq op 'let)
  1481. X           (aset regs (nth 1 inst)
  1482. X             (math-rweval
  1483. X              (math-normalize
  1484. X               (math-rwapply-replace-regs (nth 2 inst)))))
  1485. X           (setq pc (cdr pc)))
  1486. X          
  1487. X          ((eq op 'copy)
  1488. X           (aset regs (nth 2 inst) (aref regs (nth 1 inst)))
  1489. X           (setq pc (cdr pc)))
  1490. X          
  1491. X          ((eq op 'copy-neg)
  1492. X           (aset regs (nth 2 inst)
  1493. X             (math-rwapply-neg (aref regs (nth 1 inst))))
  1494. X           (setq pc (cdr pc)))
  1495. X          
  1496. X          ((eq op 'alt)
  1497. X           (setq btrack (cons pc btrack)
  1498. X             pc (nth 1 inst)))
  1499. X          
  1500. X          ((eq op 'end-alt)
  1501. X           (while (and btrack (not (eq (car btrack) (nth 1 inst))))
  1502. X             (setq btrack (cdr btrack)))
  1503. X           (setq btrack (cdr btrack)
  1504. X             pc (cdr pc)))
  1505. X          
  1506. X          ((eq op 'done)
  1507. X           (setq result (math-rwapply-replace-regs (nth 1 inst)))
  1508. X           (if (or (and (eq (car-safe result) '+)
  1509. X                (eq (nth 2 result) 0))
  1510. X               (and (eq (car-safe result) '*)
  1511. X                (eq (nth 2 result) 1)))
  1512. X               (setq result (nth 1 result)))
  1513. X           (setq part (and (nth 2 inst)
  1514. X                   (math-is-true
  1515. X                    (math-rweval
  1516. X                     (math-simplify
  1517. X                      (math-rwapply-replace-regs
  1518. X                       (nth 2 inst)))))))
  1519. X           (if (or (equal result expr)
  1520. X               (equal (setq result (math-normalize result)) expr))
  1521. X               (setq result nil)
  1522. X             (if part (math-rwapply-remember expr result))
  1523. X             (setq rules nil))
  1524. X           (setq pc nil))
  1525. X          
  1526. X          (t (error "%s is not a valid rewrite opcode" op))))))
  1527. X       (setq rules (cdr rules)))
  1528. X     result))
  1529. )
  1530. X
  1531. (defun math-rwapply-neg (expr)
  1532. X  (if (and (consp expr)
  1533. X       (memq (car expr) '(* /)))
  1534. X      (if (Math-objectp (nth 2 expr))
  1535. X      (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
  1536. X    (list (car expr)
  1537. X          (if (Math-objectp (nth 1 expr))
  1538. X          (math-neg (nth 1 expr))
  1539. X        (list '* -1 (nth 1 expr)))
  1540. X          (nth 2 expr)))
  1541. X    (math-neg expr))
  1542. )
  1543. X
  1544. (defun math-rwapply-inv (expr)
  1545. X  (if (and (Math-integerp expr)
  1546. X       calc-prefer-frac)
  1547. X      (math-make-frac 1 expr)
  1548. X    (list '/ 1 expr))
  1549. )
  1550. X
  1551. (defun math-rwapply-replace-regs (expr)
  1552. X  (cond ((Math-primp expr)
  1553. X     expr)
  1554. X    ((eq (car expr) 'calcFunc-register)
  1555. X     (setq expr (aref regs (nth 1 expr)))
  1556. X     (if (eq (car-safe expr) '*)
  1557. X         (if (eq (nth 1 expr) -1)
  1558. X         (math-neg (nth 2 expr))
  1559. X           (if (eq (nth 1 expr) 1)
  1560. X           (nth 2 expr)
  1561. X         expr))
  1562. X       expr))
  1563. X    ((and (eq (car expr) 'calcFunc-eval)
  1564. X          (= (length expr) 2))
  1565. X     (calc-with-default-simplification
  1566. X      (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
  1567. X    ((and (eq (car expr) 'calcFunc-evalsimp)
  1568. X          (= (length expr) 2))
  1569. X     (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
  1570. X    ((and (eq (car expr) 'calcFunc-evalextsimp)
  1571. X          (= (length expr) 2))
  1572. X     (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
  1573. X    ((and (eq (car expr) 'calcFunc-apply)
  1574. X          (= (length expr) 3))
  1575. X     (let ((func (math-rwapply-replace-regs (nth 1 expr)))
  1576. X           (args (math-rwapply-replace-regs (nth 2 expr)))
  1577. X           call)
  1578. X       (if (and (math-vectorp args)
  1579. X            (not (eq (car-safe (setq call (math-build-call
  1580. X                           (math-var-to-calcFunc func)
  1581. X                           (cdr args))))
  1582. X                 'calcFunc-call)))
  1583. X           call
  1584. X         (list 'calcFunc-apply func args))))
  1585. X    ((and (eq (car expr) 'calcFunc-cons)
  1586. X          (= (length expr) 3))
  1587. X     (let ((head (math-rwapply-replace-regs (nth 1 expr)))
  1588. X           (tail (math-rwapply-replace-regs (nth 2 expr))))
  1589. X       (if (math-vectorp tail)
  1590. X           (cons 'vec (cons head (cdr tail)))
  1591. X         (list 'calcFunc-cons head tail))))
  1592. X    ((and (eq (car expr) 'calcFunc-rcons)
  1593. X          (= (length expr) 3))
  1594. X     (let ((head (math-rwapply-replace-regs (nth 1 expr)))
  1595. X           (tail (math-rwapply-replace-regs (nth 2 expr))))
  1596. X       (if (math-vectorp head)
  1597. X           (append head (list tail))
  1598. X         (list 'calcFunc-rcons head tail))))
  1599. X    ((and (eq (car expr) 'neg)
  1600. X          (math-rwapply-reg-looks-negp (nth 1 expr)))
  1601. X     (math-rwapply-reg-neg (nth 1 expr)))
  1602. X    ((and (eq (car expr) 'neg)
  1603. X          (eq (car-safe (nth 1 expr)) 'calcFunc-register)
  1604. X          (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
  1605. X     (math-neg (math-rwapply-replace-regs (nth 1 expr))))
  1606. X    ((and (eq (car expr) '+)
  1607. X          (math-rwapply-reg-looks-negp (nth 1 expr)))
  1608. X     (list '- (math-rwapply-replace-regs (nth 2 expr))
  1609. X           (math-rwapply-reg-neg (nth 1 expr))))
  1610. X    ((and (eq (car expr) '+)
  1611. X          (math-rwapply-reg-looks-negp (nth 2 expr)))
  1612. X     (list '- (math-rwapply-replace-regs (nth 1 expr))
  1613. X           (math-rwapply-reg-neg (nth 2 expr))))
  1614. X    ((and (eq (car expr) '-)
  1615. X          (math-rwapply-reg-looks-negp (nth 2 expr)))
  1616. X     (list '+ (math-rwapply-replace-regs (nth 1 expr))
  1617. X           (math-rwapply-reg-neg (nth 2 expr))))
  1618. X    ((eq (car expr) '*)
  1619. X     (cond ((eq (nth 1 expr) -1)
  1620. X        (if (math-rwapply-reg-looks-negp (nth 2 expr))
  1621. X            (math-rwapply-reg-neg (nth 2 expr))
  1622. X          (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
  1623. X           ((eq (nth 1 expr) 1)
  1624. X        (math-rwapply-replace-regs (nth 2 expr)))
  1625. X           ((eq (nth 2 expr) -1)
  1626. X        (if (math-rwapply-reg-looks-negp (nth 1 expr))
  1627. X            (math-rwapply-reg-neg (nth 1 expr))
  1628. X          (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
  1629. X           ((eq (nth 2 expr) 1)
  1630. X        (math-rwapply-replace-regs (nth 1 expr)))
  1631. X           (t
  1632. X        (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
  1633. X              (arg2 (math-rwapply-replace-regs (nth 2 expr))))
  1634. X          (cond ((and (eq (car-safe arg1) '/)
  1635. X                  (eq (nth 1 arg1) 1))
  1636. X             (list '/ arg2 (nth 2 arg1)))
  1637. X            ((and (eq (car-safe arg2) '/)
  1638. X                  (eq (nth 1 arg2) 1))
  1639. X             (list '/ arg1 (nth 2 arg2)))
  1640. X            (t (list '* arg1 arg2)))))))
  1641. X    ((eq (car expr) '/)
  1642. X     (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
  1643. X           (arg2 (math-rwapply-replace-regs (nth 2 expr))))
  1644. X       (if (eq (car-safe arg2) '/)
  1645. X           (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
  1646. X         (list '/ arg1 arg2))))
  1647. X    ((and (eq (car expr) 'calcFunc-plain)
  1648. X          (= (length expr) 2))
  1649. X     (if (Math-primp (nth 1 expr))
  1650. X         (nth 1 expr)
  1651. X       (if (eq (car (nth 1 expr)) 'calcFunc-register)
  1652. X           (aref regs (nth 1 (nth 1 expr)))
  1653. X         (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
  1654. X                          (cdr (nth 1 expr)))))))
  1655. X    (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
  1656. )
  1657. X
  1658. (defun math-rwapply-reg-looks-negp (expr)
  1659. X  (if (eq (car-safe expr) 'calcFunc-register)
  1660. X      (math-looks-negp (aref regs (nth 1 expr)))
  1661. X    (if (memq (car-safe expr) '(* /))
  1662. X    (or (math-rwapply-reg-looks-negp (nth 1 expr))
  1663. X        (math-rwapply-reg-looks-negp (nth 2 expr)))))
  1664. )
  1665. X
  1666. (defun math-rwapply-reg-neg (expr)  ; expr must satisfy rwapply-reg-looks-negp
  1667. X  (if (eq (car expr) 'calcFunc-register)
  1668. X      (math-neg (math-rwapply-replace-regs expr))
  1669. X    (if (math-rwapply-reg-looks-negp (nth 1 expr))
  1670. X    (math-rwapply-replace-regs (list (car expr)
  1671. X                     (math-rwapply-reg-neg (nth 1 expr))
  1672. X                     (nth 2 expr)))
  1673. X      (math-rwapply-replace-regs (list (car expr)
  1674. X                       (nth 1 expr)
  1675. X                       (math-rwapply-reg-neg (nth 2 expr))))))
  1676. )
  1677. X
  1678. (defun math-rwapply-remember (old new)
  1679. X  (let ((varval (symbol-value (nth 2 (car ruleset))))
  1680. X    (rules (assq (car-safe old) ruleset)))
  1681. SHAR_EOF
  1682. true || echo 'restore of calc-rewr.el failed'
  1683. fi
  1684. echo 'End of  part 25'
  1685. echo 'File calc-rewr.el is continued in part 26'
  1686. echo 26 > _shar_seq_.tmp
  1687. exit 0
  1688. exit 0 # Just in case...
  1689. -- 
  1690. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1691. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1692. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1693. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1694.